;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;color-examples.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;  This file defines some color records
;;  and demonstrates some simple Mac II color hacking
;;

(proclaim '(object-variable wptr))

(eval-when (eval compile load)
  (require 'traps)
  (require 'records)
  (require 'quickdraw)
  
  (defrecord RGBColor
    (red :integer)
    (green :integer)
    (blue :integer))
  
  (defrecord ColorSpec
    (value :integer)
    (rgb :RGBColor))
  
  (defrecord (ColorTable :handle)
    (ctSeed :longint)
    (transIndex :integer)
    (ctSize :integer)
    (ctTable :colorSpec))
  
  (defrecord (PixMap :handle)
    (baseAddr :pointer)
    (rowBytes :integer)
    (bounds :rect)
    (xersion :integer)
    (packType :integer)
    (packSize :longint)
    (hRes :longint)
    (vRes :longint)
    (pixelType :integer)
    (pixelSize :integer)
    (cmpCount :integer)
    (cmpSize :integer)
    (planeBytes :longint)
    (Table :handle)
    (Reserved :longint))
  
  (defrecord (PixPat :handle)
    (patType :integer)
    (patMap :handle)
    (patData :handle)
    (patXData :handle)
    (patXValid :integer)
    (patXMap :handle)
    (pat1Data :pattern))
  
  (defrecord CGrafPort
    (device :integer)
    (portPixMap :handle)
    (portVersion :integer)
    (grafVars :handle)
    (chExtra :integer)
    (plLocHFrac :integer)
    (portRect :rect)
    (visRgn (region :handle))
    (clipRgn (region :handle))
    (bkPixPat :handle)
    (rgbFgColor :RGBColor)
    (rgbBkColor :RGBColor)
    (pnLoc point)
    (pnSize point)
    (pnMode integer)
    (pnPixPat :handle)
    (fillPixPat :handle)
    (pnVis integer)
    (txFont integer)
    (txFace integer)
    (txMode integer)
    (txSize integer)
    (spExtra longint)
    (fgColor longint)
    (bkcolor longint)
    (colrBit integer)
    (patStretch integer)
    (picSave handle)
    (rgnSave handle)
    (polySave handle)
    (grafProcs pointer))
  
  (defrecord (GrafDevice :handle)
    (RefNum :integer)
    (ID :integer)
    (Type :integer)
    (ITable :handle)
    (ResPref :integer)
    (SearchProc :pointer)
    (CompProc :pointer)
    (Flags :integer)
    (PMap :handle)
    (RefCon :longint)
    (NextGD :handle)
    (Rect :rect)
    (Mode :longint)
    (CCBytes :integer)
    (CCDepth :integer)
    (CCXData :handle)
    (CCXMask :handle)
    (Reserved :longint))
  
  (defrecord (CCrsr :handle)
    (Type :integer)
    (Map (:PixMap :handle))
    (Data :handle)
    (XData :handle)
    (XValid :integer)
    (XHandle :handle)
    (1Data :bits16)
    (Mask :bits16)
    (HotSpot :point)
    (XTable :longint)
    (ID :longint))
  
  (defrecord (CIcon :handle)
    (PMap :PixMap)
    (Mask :BitMap)
    (BMap :BitMap)
    (Data :handle)
    (MaskData :integer)))

(defobject *color-window* *window*)

(defobfun (color-window-p *window*) ()
  (eq #xc000 (logand #xc000 (rref wptr grafport.portbits.rowbytes))))

(defobfun (exist *color-window*) (init-list)
  (let ((window-title (getf init-list :window-title "Color Window"))
        (window-size (getf init-list :window-size #@(300 300)))
        (window-position (getf init-list :window-position #@(100 50)))
        (window-show (getf init-list :window-show t))
        (window-layer (getf init-list :window-layer 0)))
    (without-interrupts
     (usual-exist 
      (init-list-default 
       init-list
       :wptr
       (rlet ((r :rect :topleft window-position
                 :bottomright (add-points window-position window-size)))
         (with-pstrs ((sp window-title))
           (_NewCWindow :ptr nil
                        :ptr r
                        :ptr sp
                        :word 0
                        :word 0
                        :ptr nil
                        :word -1
                        :long 0
                        :ptr)))))
     (if (zerop window-layer)
       (window-select)
       (set-window-layer window-layer))
     (when window-show (window-show)))))

(defobfun (set-bgcolor *color-window*) (red green blue)
  (rlet ((color :rgbcolor :red red :green green :blue blue))
    (with-port wptr
      (_rgbbackcolor :ptr color)
      (_eraserect :ptr (rref wptr window.portrect)))))

(defobfun (set-fgcolor *color-window*) (red green blue)
  (rlet ((color :rgbcolor :red red :green green :blue blue))
    (with-port wptr
      (_rgbforecolor :ptr color))))

(defobfun (set-pen-rgb-pat *color-window*) (red green blue)
  (let ((pixpat (%get-ptr wptr #x3a)))
    (rlet ((rgb :rgbcolor :red red :green green :blue blue))
      (_MakeRGBPat :ptr pixpat :ptr rgb))
    (_PenPixPat :ptr pixpat)))

(defun user-pick-color (&optional (red 0) (green 0) (blue 0) 
                                  (prompt "Pick a color") &aux ok)
  (rlet ((rgb :rgbcolor :red red :green green :blue blue))
    (with-pstrs ((pp prompt))
      (setq ok (logbitp 8 (_Pack12 :long #@(40 100)
                                   :ptr pp
                                   :ptr rgb
                                   :ptr rgb
                                   :word 9
                                   :word))))
    (if ok 
      (list (%get-word rgb 0)
              (%get-word rgb 2)
              (%get-word rgb 4))
      (list red green blue))))

(defobfun (show-all-colors *color-window*) ()
  (let* ((pm (rref wptr cgrafport.portpixmap))
         (ct (rref pm pixmap.table))
         (num (1+ (rref ct colortable.ctsize)))
         (inc (record-length :colorspec))
         (start (field-info :colortable :cttable))
         (side (isqrt num))
         (hsize (floor (- (rref wptr window.portrect.right)
                          (rref wptr window.portrect.left))
                       side))
         (vsize (floor (- (rref wptr window.portrect.bottom)
                          (rref wptr window.portrect.top))
                       side))
         (wrap (* hsize side)))
    (with-dereferenced-handles ((cp ct))
      (do* ((spec (%inc-ptr cp (car (field-info :colortable :cttable)))
                  (%inc-ptr spec inc))
            (hpos 0 (+ hpos hsize))
            (vpos 0)
            (count num (1- count)))
           ((eq count 0))
        (if (>= hpos wrap) (setq hpos 0 vpos (+ vpos vsize)))
        (set-fgcolor (rref spec colorspec.rgb.red)
                     (rref spec colorspec.rgb.green)
                     (rref spec colorspec.rgb.blue))
        (paint-rect hpos vpos (+ hpos hsize) (+ vpos vsize))))))


;;The following are specific examples

(setq cw1 (oneof *color-window*
                 :window-title "All Colors"
                 :window-position #@(4 50)))

(defobfun (window-draw-contents cw1) ()
  (show-all-colors))

(ask cw1 (window-draw-contents))

(defobfun (set-window-size cw1) (h &optional v)
  (with-port wptr
    (_InvalRect :ptr (rref wptr window.portrect)))
  (usual-set-window-size h v))

(defobfun (window-click-event-handler cw1) (where)
  (declare (ignore where))
  (with-port wptr
    (rlet ((rgb :rgbcolor :red 0 :green 0 :blue 0))
      (_GetCPixel :long (window-mouse-position) :ptr rgb)
      (let* ((red (%get-word rgb 0))
             (green (%get-word rgb 2))
             (blue (%get-word rgb 4)))
        (user-pick-color red green blue)))))

(setq cw2 (oneof *color-window*
                 :window-title "Assorted Ovals"
                 :window-position #@(305 50)))

(defobfun (window-click-event-handler cw2) (where)
  (declare (ignore where))
  (tagbody loop
           (when (mouse-down-p)
             (let ((place (window-mouse-position)))
               (set-pen-rgb-pat (random 65535) (random 65535) (random 65535))
               (paint-oval place (add-points place 
                                             (make-point (random 200) (random 200))))
             (go loop)))))

(ask cw2 (move-to 50 50))
(princ "Click Here" cw2)
